home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / sources.lha / sources / sys / string.t < prev    next >
Encoding:
Text File  |  1988-02-05  |  10.9 KB  |  291 lines
  1. (herald string (env tsys))
  2.  
  3. ;;; Copyright (c) 1985 Yale University
  4. ;;;     Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
  5. ;;; This material was developed by the T Project at the Yale University Computer 
  6. ;;; Science Department.  Permission to copy this software, to redistribute it, 
  7. ;;; and to use it for any purpose is granted, subject to the following restric-
  8. ;;; tions and understandings.
  9. ;;; 1. Any copy made of this software must include this copyright notice in full.
  10. ;;; 2. Users of this software agree to make their best efforts (a) to return
  11. ;;;    to the T Project at Yale any improvements or extensions that they make,
  12. ;;;    so that these may be included in future releases; and (b) to inform
  13. ;;;    the T Project of noteworthy uses of this software.
  14. ;;; 3. All materials developed as a consequence of the use of this software
  15. ;;;    shall duly acknowledge such use, in accordance with the usual standards
  16. ;;;    of acknowledging credit in academic research.
  17. ;;; 4. Yale has made no warrantee or representation that the operation of
  18. ;;;    this software will be error-free, and Yale is under no obligation to
  19. ;;;    provide any services, by way of maintenance, update, or otherwise.
  20. ;;; 5. In conjunction with products arising from the use of this material,
  21. ;;;    there shall be no use of the name of the Yale University nor of any
  22. ;;;    adaptation thereof in any advertising, promotional, or sales literature
  23. ;;;    without prior written consent from Yale in each case.
  24. ;;;
  25.  
  26. (lset *string-delimiter* #\doublequote)
  27.  
  28. (define (make-string size)
  29.   (let ((size (enforce nonnegative-fixnum? size)))
  30.     (let ((string (make-vector-extend header/slice size 2)))
  31.       (set (string-text string) (make-text size))
  32.       string)))
  33.  
  34. ;;; string header manipulation
  35.  
  36. (define (chopy string)
  37.   (let ((string (enforce string? string)))
  38.     (let ((new (%make-extend (extend-header string) %%slice-size)))
  39.       (set (string-text new) (string-text string))
  40.       (set (mref-integer new 4) (mref-integer string 4))
  41.       new)))
  42.  
  43. (define (chopy! dest source)
  44.   (let ((dest (enforce string? dest))
  45.         (source (enforce string? source)))
  46.     (set (extend-header dest) (extend-header source))
  47.     (set (string-text dest) (string-text source))
  48.     (set (mref-integer dest 4) (mref-integer source 4))
  49.     dest))
  50.  
  51. (define (string-replace dest source count)
  52.   (let ((dest (enforce string? dest))
  53.         (source (enforce string? source))
  54.         (count (enforce nonnegative-fixnum? count)))
  55.     (do ((i 0 (fx+ i 1)))
  56.         ((fx>= i count) dest)
  57.       (set (nthchar dest i) (nthchar source i)))))
  58.  
  59. (define (copy-string string)
  60.   (let ((string (enforce string? string)))
  61.     (let ((len (string-length string)))
  62.       (string-replace (make-string len) string len))))
  63.  
  64. (define (string-equal? s1 s2)
  65.   (let ((s1 (enforce string? s1))
  66.         (s2 (enforce string? s2)))
  67.     (%string-equal? s1 s2)))
  68.                   
  69. (define (%string-equal? s1 s2)
  70.   (and (eq? (extend-header s1) (extend-header s2))
  71.        (let ((len (string-length s1))
  72.              (s1-text (string-text s1))
  73.              (s2-text (string-text s2)))
  74.          (iterate loop ((i 0) 
  75.                         (s1-i (mref-integer s1 4)) 
  76.                         (s2-i (mref-integer s2 4)))
  77.            (cond ((fx>= i len) t)
  78.                  ((char= (text-elt s1-text s1-i) (text-elt s2-text s2-i)) 
  79.                   (loop (fx+ i 1) (fx+ s1-i 1) (fx+ s2-i 1)))
  80.                  (else nil))))))
  81.  
  82.  
  83.                   
  84.  
  85. (define (list->string l)
  86.   (let ((l (enforce list? l)))
  87.     (let ((len (length l)))
  88.       (let ((str (make-string len)))
  89.         (do ((i 0 (fx+ i 1))
  90.              (l l (cdr l)))
  91.             ((fx= i len) str)
  92.           (set (nthchar str i) (car l)))))))
  93.  
  94. (define (string->list s)
  95.   (let ((s (enforce string? s)))
  96.     (do ((i (fx- (string-length s) 1) (fx- i 1))
  97.          (l '() (cons (nthchar s i) l)))
  98.         ((fx< i 0) l))))
  99.  
  100. (define (string-append . strings)
  101.   (do ((l strings (cdr l))
  102.        (n 0 (fx+ n (string-length (enforce string? (car l))))))
  103.       ((null? l)
  104.        (let ((newstring (make-string n)))
  105.          (do ((l strings (cdr l))
  106.               (n (chopy newstring) (nthchdr! n (string-length (car l)))))
  107.              ((null? l) newstring)
  108.            (string-replace n (car l) (string-length (car l))))))))
  109.  
  110. (define (string-slice string start count)
  111.   (let ((string (enforce string? string))
  112.         (start (enforce nonnegative-fixnum? start))
  113.         (count (enforce nonnegative-fixnum? count)))
  114.     (let ((new-string (nthchdr string start)))
  115.       (cond ((fx>= (string-length new-string) count)
  116.              (set (string-length new-string) count)
  117.              new-string)
  118.             (else
  119.              (error "inconsistent arguments~
  120.                    ~%  (~s ~s ~s ~s)"
  121.                     'string-slice string start count))))))
  122.  
  123. (define (substring string start count)
  124.   (let ((string (enforce string? string))
  125.         (start (enforce nonnegative-fixnum? start))
  126.         (count (enforce nonnegative-fixnum? count)))
  127.     (let ((new (make-string count)))
  128.       (do ((i start (fx+ i 1))
  129.            (j 0 (fx+ j 1)))
  130.           ((fx= j count) new)
  131.         (set (nthchar new j) (nthchar string i))))))
  132.         
  133. ;;; mappers.
  134.  
  135. (define (walk-string fn string)         ; cf. walk-vector
  136.   (let ((string (enforce string? string)))
  137.     (let ((limit (fx- (string-length string) 1)))
  138.       (cond ((fx>= limit 0)
  139.              (iterate loop ((i 0))
  140.                (cond ((fx>= i limit) 
  141.                       (fn (nthchar string i)))
  142.                      (else
  143.                       (fn (nthchar string i))
  144.                       (loop (fx+ i 1))))))))))
  145.  
  146. (define (map-string proc string)
  147.   (let ((string (enforce string? string)))
  148.     (let ((len (string-length string)))
  149.       (let ((new-string (make-string len)))
  150.         (do ((i 0 (fx+ i 1)))           ; avoid chonsing
  151.             ((fx>= i len) new-string)
  152.           (set (nthchar new-string i) (proc (nthchar string i))))))))
  153.  
  154. (define (map-string! fn string)
  155.   (let ((string (enforce string? string)))
  156.     (let ((len (string-length string)))
  157.       (do ((i 0 (fx+ i 1)))
  158.           ((fx>= i len) string)
  159.         (set (nthchar string i) (fn (nthchar string i)))))))
  160.  
  161. ;;; case stuff
  162.  
  163. (define (string-upcase string)
  164.   (map-string %char-upcase string))
  165.  
  166. (define (string-downcase string)
  167.   (map-string %char-downcase string))
  168.  
  169. (define (string-invert-case string)
  170.   (map-string %char-invert-case string))
  171.  
  172. (define (string-upcase! string)
  173.   (map-string! %char-upcase string))
  174.  
  175. (define (string-downcase! string)
  176.   (map-string! %char-downcase string))
  177.  
  178. (define (string-invert-case! string)
  179.   (map-string! %char-invert-case string))
  180.  
  181. (define (string-fill string ch)
  182.   (let ((string (enforce string? string))
  183.         (ch (enforce char? ch)))
  184.     (let ((size (string-length string)))
  185.       (do ((i 0 (fx+ i 1)))
  186.           ((fx>= i size) string)
  187.         (set (nthchar string i) ch)))))
  188.  
  189. (define (char->string ch)           
  190.   (let ((ch (enforce char? ch)))
  191.     (let ((s (make-string 1)))
  192.       (set (nthchar s 0) ch)
  193.       s)))
  194.  
  195. (define (string-find-char string ch)
  196.   (let* ((string (enforce string? string))
  197.          (ch (enforce char? ch))
  198.          (len (string-length string)))
  199.       (iterate loop ((i 0))
  200.         (cond ((fx>= i len) nil)
  201.               ((char= (nthchar string i) ch) i)
  202.               (else (loop (fx+ i 1)))))))
  203.  
  204. (define (string-posq ch string) (string-find-char string ch))
  205.  
  206. (define (string-reverse-find-char string ch)
  207.   (let ((string (enforce string? string))
  208.         (ch (enforce char? ch)))
  209.     (iterate loop ((i (string-length string)))
  210.       (let ((i (fx- i 1)))
  211.         (cond ((fx< i 0) nil)
  212.               ((char= (nthchar string i) ch) i)
  213.               (else (loop i)))))))
  214.  
  215. (define-simple-switch text-elision fixnum? 20)
  216.  
  217. (define-handler text
  218.   (let ((writer (lambda (port text count)
  219.                   (let ((len (cond ((null? count) (text-length text))
  220.                                    ((fx< count (text-length text))
  221.                                     count)
  222.                                    (else (text-length text))))
  223.                         (writec (if (iob? port) vm-write-char write-char)))
  224.                     (if (fixnum? count)
  225.                         (if (fx< len (text-length text))
  226.                             (format port "#{Text (~a) " (object-hash text))
  227.                             (format port "#[Text (~a) \"" (object-hash text))))
  228.                     (do ((i 0 (fx+ i 1)))
  229.                         ((fx>= i len) (no-value))
  230.                       (writec port (text-elt text i)))
  231.                     (if (fixnum? count)
  232.                         (if (fx< len (text-length text))
  233.                             (write-string port " ... }")
  234.                             (write-string port "\"]")))))))
  235.     (object nil
  236.       ((display self port)
  237.        (writer port self nil))
  238.       ((print self port)
  239.        (writer port self (text-elision)))
  240.       ((crawl-exhibit self)
  241.        (writer (standard-output) self (text-length self))))))
  242.  
  243. (define-handler slice
  244.   (object nil
  245.     ((hash self) (string-hash self))
  246.     ((display obj port) (write-string port obj))
  247.     ((print obj port)
  248.      (print-delimited-string obj port *string-delimiter*))
  249.     ((crawl-exhibit string)
  250.      (format (terminal-output) 
  251.              " header: addr = #x~x, length = ~d, offset = ~d~%"
  252.              (descriptor->fixnum string)
  253.              (string-length string)
  254.              (mref-integer string 4))
  255.      (format (terminal-output) " text: addr = #x~x, length = ~d,~% '~a'~%"
  256.              (descriptor->fixnum (string-text string))
  257.              (text-length (string-text string))
  258.              (string-text string)))))
  259.      
  260. ;;; We should pre-scan the string to decide whether it can be
  261. ;;; blatted out with a single write-string.
  262. ;++ We should be handling control characters in strings.
  263.  
  264. (define (print-delimited-string obj port delim)
  265.   (let ((port  (enforce port? port))
  266.         (delim (enforce char? delim)))
  267.     (cond ((not (reasonable? obj))    ; robustness implies hair.  sorry.
  268.            (print-random obj port))
  269.           (else
  270.            (let ((writec (if (iob? port) vm-write-char write-char))
  271.                  (len    (string-length obj)))
  272.              (writec port delim)
  273.              (iterate loop ((i 0))
  274.                (cond  ((fx>= i len)
  275.                        (writec port delim)
  276.                        (no-value))
  277.                       (else
  278.                        (let ((ch (string-elt obj i)))
  279.                          (cond ((char= ch #\newline)
  280.                                 (newline port))
  281.                                ((%control? ch)
  282.                                 (writec port *escape-char*)
  283.                                 (writec port *control-char-delimiter*)
  284.                                 (writec port ch))
  285.                                (else
  286.                                 (if (or (char= ch delim)
  287.                                         (char= ch *escape-char*))
  288.                                     (writec port *escape-char*))
  289.                                 (writec port ch))))
  290.                        (loop (fx+ i 1))))))))))
  291.